unit VclScripter;

//  $URL: http://delphiscriptedtesting.googlecode.com/svn/InterposedVclScripter/Main/VclScripter.pas $
//  $Revision: 1222 $
//  $Date: 2010-05-02 15:23:36 +0000 (Sun, 02 May 2010) $

interface

uses
  Classes, Contnrs, T_Rex;

type
  TEventType = (etEvent, etAssignment);

const
  EventTypeName : array [TEventType] of string = ('Event','Field');

type
  TProgressReporter = procedure (Sender: TObject; const Message: string) of object;

  TScriptLine = class
  private
    FTimestamp:          TDateTime;
    FOwnerFormClassName: string;
    FOwnerFormName:      string;
    FComponentClassName: string;
    FComponentName:      string;
    FEventType:          TEventType;
    FFieldName:          string;
    FFieldValue:         string;
  public
    constructor Create(const AnOwnerFormClassName, AnOwnerFormName, AComponentClassName, AComponentName: string;
                       const AnEventType: TEventType; const AFieldName: string; const AFieldValue: string = '');
  end;

  TScriptLineList = class(TObjectList)
  public
    procedure NonRedundantAdd(AScriptLine: TScriptLine);
  end;

  TScriptWriter = class
  private
    FScriptFileName:   string;
    FScriptLineNumber: integer;
    FScriptLineList:   TScriptLineList;
    FProgressReporter: TProgressReporter;
  public
    constructor Create(AScriptFileName: string);
    destructor Destroy; override;
    function LogToFile(Sender: TComponent; EventName: string; Debug: boolean = True): boolean; overload;
    function LogToFile(Sender: TComponent; FieldName: string; FieldValue: string; Debug: boolean = True): boolean; overload;
    property ScriptFileName: string read FScriptFileName;
    property ProgressReporter: TProgressReporter read FProgressReporter write FProgressReporter;
  end;

  TScriptReader = class
  private
    FScriptTextFile:       TextFile;
    FScriptFileName:       string;
    FRawScriptLine:        string;
    FScriptStrings:        TStringList;
    FScriptEventLineRE:    TRegExp;
    FScriptFieldLineRE:    TRegExp;
    FScriptLineNumber:     integer;
    FScriptInterval:       integer;
    FScriptKill:           integer;
    FTriggered:            boolean;
    FPaused:               boolean;
    FHalting:              boolean;
    FProgressReporter:     TProgressReporter;
    constructor Create(AScriptFileName: string);
    procedure ParseAction;
    procedure ExecuteAction;
  public
    function NextScriptAction: boolean;
    procedure Run (Sender: TObject);
    procedure Halt (Sender: TObject);
    property ScriptFileName: string read FScriptFileName;
    property Triggered: boolean read FTriggered write FTriggered;
    property Paused: boolean read FPaused write FPaused;
    property ScriptKill: integer read FScriptKill write FScriptKill;
    property ScriptLineNumber: integer read FScriptLineNumber;
    property ProgressReporter: TProgressReporter write FProgressReporter;
    destructor Destroy;  override;
  end;

var
  ScriptWriter: TScriptWriter;
  ScriptReader: TScriptReader;
  ReaderParam:  TRegExp;
  WriterParam:  TRegExp;
  IntervalParam:TRegExp;
  KillParam:    TRegExp;
  ParamNo:      integer;

implementation

uses
  Windows, Forms, SysUtils, Dialogs, TypInfo;

var
  SymbolicLocation: string;
  ActualLocation: array [0..255] of char;
  ScriptID: string;
  ScriptFilename: string;
  ms, ml: cardinal;

{ ================ TScriptWriter ==================== }
{          Record GUI events to a textfile            }
{ =================================================== }

constructor TScriptWriter.Create(AScriptFileName: string);

begin
inherited Create;
FScriptFileName := AScriptFileName;
FScriptLineList := TScriptLineList.Create;
DeleteFile(FScriptFileName);
end;

destructor TScriptWriter.Destroy;

var
  f: TextFile;
  l: TScriptLine;
  p: pointer;

begin
System.AssignFile(f, FScriptFileName);
if Sysutils.FileExists(FScriptFileName) then
  System.Append(f)
else
  System.Rewrite(f);
try
for p in FScriptLineList do
  begin
  l := TScriptLine(p);
  if l.FEventType = etAssignment then
    Write(f,
         DateTimeToStr(l.FTimestamp),';',
         l.FOwnerFormClassName,      ';',
         l.FOwnerFormName,           ';',
         l.FComponentClassName,      ';',
         l.FComponentName,           ';',
         'Field',                    ';',
         l.FFieldName,               ';',
         l.FFieldValue)
  else
    Write(f,
         DateTimeToStr(l.FTimestamp),';',
         l.FOwnerFormClassName,      ';',
         l.FOwnerFormName,           ';',
         l.FComponentClassName,      ';',
         l.FComponentName,           ';',
         'Event',                    ';',
         l.FFieldName);
  Writeln(f);
  end;
finally
CloseFile(f);
end;

inherited;
end;

function TScriptWriter.LogToFile(Sender: TComponent; FieldName,
  FieldValue: string; Debug: boolean): boolean;

begin
result := false;
if not Assigned(Sender) then
  exit;
try
inc(FScriptLineNumber);
if Assigned(FProgressReporter) then
  FProgressReporter(Sender, Format('Writing script line %d', [FScriptLineNumber]));
FScriptLineList.NonRedundantAdd(
  TScriptLine.Create(
         Sender.Owner.ClassName,
         Sender.Owner.Name,
         Sender.ClassName,
         Sender.Name,
         etAssignment,
         FieldName,
         FieldValue));
except
on E: Exception do
  begin
  MessageDlg(E.Message, mtError, [mbOk], 0);
  raise;
  end;
end;
result := true;
end;

function TScriptWriter.LogToFile(Sender: TComponent; EventName: string; Debug: boolean = True): boolean;

begin
result := false;
if not Assigned(Sender) then
  exit;
try
inc(FScriptLineNumber);
if Assigned(FProgressReporter) then
  FProgressReporter(Sender, Format('Writing script line %d', [FScriptLineNumber]));
FScriptLineList.Add(
  TScriptLine.Create(
         Sender.Owner.ClassName,
         Sender.Owner.Name,
         Sender.ClassName,
         Sender.Name,
         etEvent,
         EventName));
except
on E: Exception do
  begin
  MessageDlg(E.Message, mtError, [mbOk], 0);
  raise;
  end;
end;
result := true;
end;

{ ================ TScriptReader ==================== }
{       Play back GUI events from a textfile          }
{ =================================================== }

constructor TScriptReader.Create(AScriptFileName: string);
begin
inherited Create;
FScriptEventLineRE := TRegExp.Create('[^;]+;[^;]+;[^;]+;[^;]+;[^;]+;Event;.+');
FScriptFieldLineRE := TRegExp.Create('[^;]+;[^;]+;[^;]+;[^;]+;[^;]+;Field;[^;]+;.+');
FScriptStrings := TStringList.Create;
FScriptFileName := AScriptFileName;
FScriptLineNumber := 0;
Assign(FScriptTextFile, FScriptFileName);
Reset(FScriptTextFile);
end;

destructor TScriptReader.Destroy;
begin
FreeAndNil(FScriptStrings);
CloseFile(FScriptTextFile);
inherited Destroy;
end;

procedure TScriptReader.Run;
begin
if FTriggered then
  exit;
while NextScriptAction do
  begin
  ParseAction;
  ExecuteAction;
  if FScriptInterval > 0 then SleepEx(FScriptInterval, false);
  Application.ProcessMessages;
  end;
FTriggered := true;
end;

function TScriptReader.NextScriptAction: boolean;

begin
Result := false;
if eof(FScriptTextFile) then
  exit;
inc(FScriptLineNumber);
readln(FScriptTextFile, FRawScriptLine);
Result := not FHalting; // Normally we are not halting so this returns true until eof.
end;

procedure TScriptReader.ParseAction;

var
  ms, ml: cardinal;

begin
assert(FScriptEventLineRE.Match(FRawScriptLine, ms, ml)
  or   FScriptFieldLineRE.Match(FRawScriptLine, ms, ml),
  Format('Could not parse script line "%s" at line %d of %s', [FRawScriptLine, FScriptLineNumber, FScriptFileName]));
FScriptStrings.Text := StringReplace(FRawScriptLine, ';', #13, [rfReplaceAll]);
if Assigned(FProgressReporter) then
  if FScriptStrings[5] = 'Event' then
    FProgressReporter(Self, Format('Processing script line %d: %s.%s.%s()', [FScriptLineNumber,
    FScriptStrings[2],FScriptStrings[4],FScriptStrings[6]]))
  else
    FProgressReporter(Self, Format('Processing script line %d: %s.%s.%s := %s', [FScriptLineNumber,
    FScriptStrings[2],FScriptStrings[4],FScriptStrings[6],FScriptStrings[7]]));
end;

procedure TScriptReader.ExecuteAction;

var
  form: TCustomForm;
  comp: TComponent;
  i: Integer;
  j: Integer;

  procedure ExecMethod(OnObject: TObject; MethodName: string) ;

  type
    TExec = procedure of object;

  var
    Routine: TMethod;
    Exec: TExec;

  begin
  Routine.Data := Pointer(OnObject) ;
  Routine.Code := OnObject.MethodAddress(MethodName) ;
  if not Assigned(Routine.Code) then
    exit;
  Exec := TExec(Routine) ;
  Exec;
  end;

  procedure AssignField(OnObject: TObject; FieldName: string; FieldValue: Variant) ;

  begin
  SetPropValue(OnObject, FieldName, FieldValue);
  end;

begin
for i := 0 to Screen.CustomFormCount - 1 do
  begin
  form := Screen.CustomForms[i];
  if form.ClassNameIs(FScriptStrings[1]) and (form.Name = FScriptStrings[2]) then
    begin
    for j := 0 to form.ComponentCount - 1 do
      begin
      comp := form.Components[j];
      if comp.ClassNameIs(FScriptStrings[3]) and (comp.Name = FScriptStrings[4]) then
        if (FScriptStrings[5] = 'Event') then
          ExecMethod(comp, FScriptStrings[6])
        else
          AssignField(comp, FScriptStrings[6], FScriptStrings[7])
      end;
    end;
  end;
end;

procedure TScriptReader.Halt(Sender: TObject);
begin
FHalting := true;
end;

{ TScriptLine }

constructor TScriptLine.Create(const AnOwnerFormClassName, AnOwnerFormName,
  AComponentClassName, AComponentName: string; const AnEventType: TEventType;
  const AFieldName, AFieldValue: string);
begin
FTimestamp :=           Now();
FOwnerFormClassName :=  AnOwnerFormClassName;
FOwnerFormName :=       AnOwnerFormName;
FComponentClassName :=  AComponentClassName;
FComponentName :=       AComponentName;
FEventType :=           AnEventType;
FFieldName :=           AFieldName;
FFieldValue :=          AFieldValue;
end;

{ TScriptLineList }

procedure TScriptLineList.NonRedundantAdd(AScriptLine: TScriptLine);

var
  index:  integer;
  Latest: TScriptLine;

begin
if Self.Count > 0 then
  begin
  index := pred(self.Count);
  Latest := Self.Items[index] as TScriptLine;
  if  (Latest.FOwnerFormClassName = AScriptLine.FOwnerFormClassName)
  and (Latest.FOwnerFormName      = AScriptLine.FOwnerFormName)
  and (Latest.FComponentClassName = AScriptLine.FComponentClassName)
  and (Latest.FComponentName      = AScriptLine.FComponentName)
  and (Latest.FEventType          = AScriptLine.FEventType)
  and (Latest.FFieldName          = AScriptLine.FFieldName) then
    Self.Delete(index);
  end;
Add(AScriptLine);
end;

initialization

{$IFDEF SCRIPTABLE}

ScriptReader := nil;
ScriptWriter := nil;

ReaderParam   := TRegExp.Create('^[-/]playback$');
WriterParam   := TRegExp.Create('^[-/]record$');
IntervalParam := TRegExp.Create('^[-/]interval$');
KillParam     := TRegExp.Create('^[-/]kill$');

if ParamCount >= 2 then
  begin
  SymbolicLocation := ChangeFileExt('%AppData%\' + ExtractFileName(Application.ExeName), '');
  ExpandEnvironmentStrings(PChar(SymbolicLocation), @ActualLocation, 256);

  for ParamNo := 1 to ParamCount do
    begin
    if WriterParam.Match(ParamStr(ParamNo), ms, ml) and (ParamCount > ParamNo) then
      // user specified an output script filename on the command line
      begin
      ScriptID := ChangeFileExt(ParamStr(ParamNo+1), '.ivs');
      ScriptFilename := string(ActualLocation) + '\' + ScriptID;
      if not DirectoryExists(string(ActualLocation)) then
        ForceDirectories(string(ActualLocation));
      ScriptWriter := TScriptWriter.Create(ScriptFilename);
      break;
      end
    else
    if ReaderParam.Match(ParamStr(ParamNo), ms, ml) and (ParamCount > ParamNo) then
      // user specified an input script filename on the command line
      begin
      ScriptID := ChangeFileExt(ParamStr(ParamNo+1), '.ivs');
      ScriptFilename := string(ActualLocation) + '\' + ScriptID;
      ScriptReader := TScriptReader.Create(ScriptFilename);
      ScriptReader.FScriptKill := maxint;
      end
    else if IntervalParam.Match(ParamStr(ParamNo), ms, ml) and (ParamCount > ParamNo) and Assigned(ScriptReader) then
      ScriptReader.FScriptInterval := StrToIntDef(ParamStr(ParamNo+1),0)
    else if KillParam.Match(ParamStr(ParamNo), ms, ml) and (ParamCount > ParamNo) and Assigned(ScriptReader) then
      ScriptReader.FScriptKill := StrToIntDef(ParamStr(ParamNo+1),0) * 1000;
    end;
  end;

finalization

if Assigned(ScriptReader) then
  ScriptReader.Free;
if Assigned(ScriptWriter) then
  ScriptWriter.Free;

{$ENDIF}
end.







